Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/graphics/bitlin/frmlha.frm

Visual Basic Form | 1995-05-23 | 10.1 KB | 349 lines

VERSION 2.00
Begin Form frmlha
   AutoRedraw      =   -1  'True
   Caption         =   "LHA file contents"
   Height          =   4440
   Left            =   825
   LinkTopic       =   "Form1"
   ScaleHeight     =   4035
   ScaleWidth      =   3315
   Top             =   1185
   Width           =   3435
   Begin CommandButton cmdVersion
      Caption         =   "LHA &Version"
      Height          =   495
      Left            =   2040
      TabIndex        =   7
      Top             =   1440
      Width           =   1095
   End
   Begin PictureBox picFile2
      Height          =   615
      Left            =   3720
      Picture         =   FRMLHA.FRX:0000
      ScaleHeight     =   585
      ScaleWidth      =   465
      TabIndex        =   6
      Top             =   960
      Width           =   495
   End
   Begin PictureBox PicFile1
      Height          =   615
      Left            =   3720
      Picture         =   FRMLHA.FRX:0302
      ScaleHeight     =   585
      ScaleWidth      =   465
      TabIndex        =   5
      Top             =   240
      Width           =   495
   End
   Begin CommandButton cmdDelete
      Caption         =   "&Delete"
      Height          =   495
      Left            =   2040
      TabIndex        =   4
      Top             =   3240
      Width           =   1095
   End
   Begin CommandButton cmdExtract
      Caption         =   "&Extract"
      Height          =   495
      Left            =   2040
      TabIndex        =   3
      Top             =   2040
      Width           =   1095
   End
   Begin CommandButton cmdCancel
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   495
      Left            =   2040
      TabIndex        =   2
      Top             =   840
      Width           =   1095
   End
   Begin CommandButton cmdOK
      Caption         =   "&OK"
      Default         =   -1  'True
      Height          =   495
      Left            =   2040
      TabIndex        =   1
      Top             =   240
      Width           =   1095
   End
   Begin ListBox lstLHAcontents
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Terminal"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   3540
      Left            =   240
      MultiSelect     =   2  '
      TabIndex        =   0
      Top             =   240
      Width           =   1575
   End
Sub cmdCancel_Click ()
' set the frmlha.tag to null
  frmLHA.Tag = ""
' hide the frmlha
frmLHA.Hide
End Sub
'Copyright 1995 by Hitoshi Ozawa
Sub cmdDelete_Click ()
Dim retcode As Integer
Dim curpath As String
Dim cnt
Dim numitem
'Reset buffer size
buffer = Space(szbuff)
'Save current path
curpath = CurDir
ChDrive Mid$(frmgetfile.Tag, 1, 2)
ChDir frmgetfile.filFiles.Path
numitem = lstLHAcontents.ListCount
cnt = 0
Do While cnt < numitem
 If lstLHAcontents.Selected(cnt) Then
   'Create LHA command
   cmd = "d " & frmgetfile.Tag & " " & lstLHAcontents.List(cnt)
   'Perform LHA operation
    retcode = lha(cmd, buffer, szbuff)
   'Check for error
   If retcode <> 0 Then
     MsgBox ("Error: " & retcode)
     Exit Sub
   End If
   lstLHAcontents.RemoveItem cnt
   numitem = numitem - 1
 Else
   cnt = cnt + 1
 End If
'Return to original drive
ChDrive Mid$(curpath, 1, 2)
'Return to original path
ChDir curpath
End Sub
'Copyright 1995 by Hitoshi Ozawa
Sub cmdDelete_DragDrop (Source As Control, X As Single, Y As Single)
Dim retcode As Integer
Dim curpath As String
Dim cnt
Dim numitem
'Save current path
curpath = CurDir
ChDrive Mid$(frmgetfile.Tag, 1, 2)
ChDir frmgetfile.filFiles.Path
numitem = lstLHAcontents.ListCount
cnt = 0
Do While cnt < numitem
 If lstLHAcontents.Selected(cnt) Then
   'Create LHA command
   cmd = "d " & frmgetfile.Tag & " " & lstLHAcontents.List(cnt)
   'Perform LHA operation
    retcode = lha(cmd, buffer, szbuff)
   'Check for error
   If retcode <> 0 Then
     MsgBox ("Error: " & retcode)
     Exit Sub
   End If
   lstLHAcontents.RemoveItem cnt
   numitem = numitem - 1
 Else
   cnt = cnt + 1
 End If
'Return to original drive
ChDrive Mid$(curpath, 1, 2)
'Return to original path
ChDir curpath
End Sub
'Copyright 1995 by Hitoshi Ozawa
Sub cmdDelete_DragOver (Source As Control, X As Single, Y As Single, State As Integer)
Select Case State
  Case 0
    'change icon to release
     lstLHAcontents.DragIcon = picFile2
  Case 1
    'change icon to release
     lstLHAcontents.DragIcon = picFile1
End Select
End Sub
'Copyright 1995 by Hitoshi Ozawa
Sub cmdExtract_Click ()
Dim retcode As Integer
Dim curpath As String
Dim cnt
'Reset buffer size
buffer = Space(szbuff)
'Save current path
curpath = CurDir
ChDrive Mid$(frmgetfile.Tag, 1, 2)
ChDir frmgetfile.filFiles.Path
For cnt = 0 To lstLHAcontents.ListCount - 1
 If lstLHAcontents.Selected(cnt) Then
   'Create LHA command
   cmd = "e " & frmgetfile.Tag & " " & lstLHAcontents.List(cnt)
   'Perform LHA operation
    retcode = lha(cmd, buffer, szbuff)
   'Check for error
   If retcode <> 0 Then
     MsgBox ("Error: " & retcode)
     Exit Sub
   End If
 End If
Next cnt
'Return to original drive
ChDrive Mid$(curpath, 1, 2)
'Return to original path
ChDir curpath
'refresh getfile file box
frmgetfile.filFiles.Refresh
End Sub
'Copyright 1995 by Hitoshi Ozawa
Sub cmdExtract_DragDrop (Source As Control, X As Single, Y As Single)
Dim retcode As Integer
Dim curpath As String
Dim cnt
'Save current path
curpath = CurDir
ChDrive Mid$(frmgetfile.Tag, 1, 2)
ChDir frmgetfile.filFiles.Path
For cnt = 0 To lstLHAcontents.ListCount - 1
 If lstLHAcontents.Selected(cnt) Then
   'Create LHA command
   cmd = "e " & frmgetfile.Tag & " " & lstLHAcontents.List(cnt)
   'Perform LHA operation
    retcode = lha(cmd, buffer, szbuff)
   'Check for error
   If retcode <> 0 Then
     MsgBox ("Error: " & retcode)
     Exit Sub
   End If
 End If
Next cnt
'Return to original drive
ChDrive Mid$(curpath, 1, 2)
'Return to original path
ChDir curpath
'refresh getfile file box
frmgetfile.filFiles.Refresh
End Sub
'Copyright 1995 by Hitoshi Ozawa
Sub cmdExtract_DragOver (Source As Control, X As Single, Y As Single, State As Integer)
Select Case State
  Case 0
    'change icon to release
     lstLHAcontents.DragIcon = picFile2
  Case 1
    'change icon to release
     lstLHAcontents.DragIcon = picFile1
End Select
End Sub
'Copyright 1995 by Hitoshi Ozawa
Sub cmdOK_Click ()
Dim retcode As Integer
Dim curpath As String
'Check if file selected
If lstLHAcontents.Text = "" Then
  frmLHA.Tag = ""
  frmLHA.Hide
End If
'Save current path
curpath = CurDir
'Change to file's drive and path
ChDrive Mid$(frmgetfile.Tag, 1, 2)
ChDir frmgetfile.filFiles.Path
'Check if file already exists
On Error GoTo ExtFile
 retcode = GetAttr(lstLHAcontents.Text)
 retcode = MsgBox("Overwrite existing file?", 308, "File already exists!")
If retcode = 6 Then
   Kill lstLHAcontents.Text
   GoTo ExtFile
 End If
Exit Sub
ExtFile:
'Create LHA command
cmd = "e " & frmgetfile.Tag & " " & lstLHAcontents.Text
'Perform LHA operation
retcode = lha(cmd, buffer, szbuff)
'Check for error
If retcode <> 0 Then
 MsgBox ("LHA.DLL Error: " & retcode)
 Exit Sub
End If
'Return to original drive
ChDrive Mid$(curpath, 1, 2)
'Return to original path
ChDir curpath
'refresh getfile file box
frmgetfile.filFiles.Refresh
'Assign selection to tag
frmLHA.Tag = lstLHAcontents.Text
frmLHA.Hide
Exit Sub
End Sub
Sub cmdVersion_Click ()
'display LHA.DLL version information
Dim retcode As Integer
'Perform LHA operation
retcode = LhaGetVersion()           'get LHA.DLL version information
retcode = MsgBox("Current Version: " & retcode, 0, "LHA.DLL Information")  'display version info
End Sub
'Copyright 1995 by Hitoshi Ozawa
Sub Form_Activate ()
'display contents of selected LZH file
Dim cnt As Integer                    'loop counter
Dim retcode As Integer                'return code
Dim stptr                             'start position pointer
Dim endptr                            'end position pointer
'Reset buffer size
buffer = Space(szbuff) & Chr(0)       'reset buffer- add chr(0) to mark end of buffer
'Clear list box
lstLHAcontents.Clear                  'clear contents list box
frmLHA.Refresh                        'redraw dialog box
'Create LHA command
cmd = "l " & frmgetfile.Tag           'make LHA command to list contents of LZH file
'Perform LHA operation
retcode = lha(cmd, buffer, szbuff)    'perform LHA operation - call LHA.DLL function
'Check for error
If retcode <> 0 Then                  'check if there was a LHA.DLL function error
 MsgBox ("Error: " & retcode)
 Exit Sub
End If
'Extract only File name from file listing returned from LHA function call
'Skip past header
endptr = InStr(buffer, "-")
stptr = InStr(endptr, buffer, Chr(10))
Do While Mid$(buffer, stptr, 1) <> "-"
'Skip past chr(10)
  stptr = InStr(stptr, buffer, " ")
'Skip past spaces
  stptr = 13 - Len(LTrim$(Mid$(buffer, stptr, 13))) + stptr
'Find end of file name
  endptr = InStr(stptr, buffer, " ")
'Add filename to list
  lstLHAcontents.AddItem Trim(Mid$(buffer, stptr, endptr - stptr))
'Skip to end of row
  stptr = InStr(stptr, buffer, Chr(10)) + 1
'Check for going past end of buffer
  If stptr >= szbuff Then
    Exit Do
  End If
lstLHAcontents.Refresh                'update list box to display file names
End Sub
'Copyright 1995 by Hitoshi Ozawa
Sub lstLHAcontents_DblClick ()
'Execute the cmdOK_Click() procedure and close frmlha
cmdOK_Click
End Sub
'Copyright 1995 by Hitoshi Ozawa
Sub lstLHAcontents_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single)
'Change drag icon
lstLHAcontents.DragIcon = picFile1
'Enable drag
lstLHAcontents.Drag
End Sub